
import Test.QuickCheck
import Data.List
import Data.Maybe

----------------------------------------------------------------------------
-- 1.

-- a.

subsets :: [a] -> [[a]]
subsets []     = [[]]
subsets (x:xs) = subsets xs ++ [x:ys | ys <- subsets xs]

-- b.

amounts :: [Int] -> [Int]
amounts xs = map sum (subsets xs)

{-
-- alternatively:
amounts xs = [ sum ys | ys <- subsets xs ]
-}

-- c.

withChange :: [Int] -> [Int] -> [Int]
withChange xs ys =
  [ a-b
  | a <- amounts xs
  , b <- amounts ys
  , b <= a
  ]

-- d (i).

bag :: Eq a => [a] -> [(a,Int)]
bag xs = [(x,count x) | x <- nub xs]
 where
  count x = length [x' | x' <- xs, x == x']

-- d (ii).

set :: [(a,Int)] -> [a]
set xns = concat [replicate n x | (x,n) <- xns]

{-
-- alternatively:
set xns = [y | (x,n) <- xns, y <- replicate n x]
-}

-- d (iii).

subbags :: [(a,Int)] -> [[(a,Int)]]
subbags []          = [[]]
subbags ((x,n):xns) = subbags xns ++
                         [(x,i):yns | yns <- subbags xns, i <- [1..n]]

{-
-- redefine the amounts function as follows:
amounts xs = map (sum . set) (subbags (bag xs))
-}

----------------------------------------------------------------------------
-- 2.

-- a.

ordered :: Ord a => [a] -> Bool
ordered (x:y:xs) = x <= y && ordered (y:xs)
ordered _        = True

-- b.

merge :: Ord a => [a] -> [a] -> [a]
merge []     ys     = ys
merge xs     []     = xs
merge (x:xs) (y:ys)
  | x <= y          = x : merge xs (y:ys)
  | otherwise       = y : merge (x:xs) ys

-- c.

interleavings :: [a] -> [a] -> [[a]]
interleavings []     ys     = [ys]
interleavings xs     []     = [xs]
interleavings (x:xs) (y:ys) =
  [x:zs | zs <- interleavings xs (y:ys)] ++
  [y:zs | zs <- interleavings (x:xs) ys]

-- d.

prop_MergeInterleaves :: [Int] -> [Int] -> Bool
prop_MergeInterleaves xs ys =
  merge xs ys `elem` interleavings xs ys 

-- e.

interleaving :: Eq a => [a] -> [a] -> [a] -> Bool
interleaving []     ys     zs     = ys == zs
interleaving xs     []     zs     = xs == zs
interleaving xs     ys     []     = False
interleaving (x:xs) (y:ys) (z:zs) =
  (x == z && interleaving xs (y:ys) zs) ||
  (y == z && interleaving (x:xs) ys zs)

-- f.

prop_MergeInterleaves' :: [Int] -> [Int] -> Bool
prop_MergeInterleaves' xs ys =
  interleaving xs ys (merge xs ys)

----------------------------------------------------------------------------
-- 3.

data Huffman
  = Leaf Char
  | Branch Huffman Huffman
 deriving (Eq,Ord,Show)

type CodeTable
  = [(Char,String)]

-- a.

encode :: CodeTable -> String -> String
encode ct s = concat [fromJust (lookup c ct) | c <- s]

{-
-- alternatively:
encode ct s = concat [encodeChar c | c <- s]
 where
  encodeChar c = s
   where
    Just s = lookup c ct
-}

-- b.

extractCodes :: Huffman -> CodeTable
extractCodes (Leaf c)     = [(c, "")]
extractCodes (Branch l r) =
  [(c, "0"++k) | (c,k) <- extractCodes l] ++
  [(c, "1"++k) | (c,k) <- extractCodes r]

-- c.

buildTree :: [(Int,Huffman)] -> Huffman
buildTree whs = build (sort whs)
 where
  build ((w1,h1):(w2,h2):whs) = build (insert (w1+w2,Branch h1 h2) whs)
  build [(w,h)]               = h

-- d.

huffmanCode :: String -> CodeTable
huffmanCode s = extractCodes (buildTree (initialTrees s))
 where
  initialTrees s = [(count c, Leaf c) | c <- nub s]
   where
    count c = length [c' | c' <- s, c==c']

-- e.

compress :: String -> String
compress s = encode (huffmanCode s) s

----------------------------------------------------------------------------
